home *** CD-ROM | disk | FTP | other *** search
/ Belgian Amiga Club - ADF Collection / BS1 part 68.7z / BS1 part 68 / InterChange Plus v3.0 (1993-11)(Syndesis)(Disk 2 of 2).7z / InterChange Plus v3.0 (1993-11)(Syndesis)(Disk 2 of 2).adf / PC_Tools.LZH / ALISP.ZIP / 3DSPRING.LSP next >
Lisp/Scheme  |  1993-10-06  |  6KB  |  195 lines
  1.  
  2.  
  3. ; by Simon Jones - Autodesk UK Ltd.
  4. ; and Duff Kurland - Autodesk, Inc.
  5. ; November, 1986
  6.  
  7.  
  8. ; Syetem variable save
  9. (defun modes (a)
  10.    (setq MLST nil)
  11.    (repeat (length a)
  12.       (setq MLST (append MLST (list (list (car a) (getvar (car a))))))
  13.       (setq a (cdr a)))
  14. )
  15.  
  16. ; Syetem variable restore
  17. (defun moder ()
  18.    (repeat (length MLST)
  19.       (setvar (caar MLST) (cadar MLST))
  20.       (setq MLST (cdr MLST))
  21.    )
  22. )
  23.  
  24. ; Convert degrees to radians
  25. (defun dtr (a)
  26.    (* pi (/ a 180.0))
  27. )
  28.  
  29. ; Select all entities added since checkpoint.
  30. (defun selstuff (e)
  31.    (setq ss nil)                      ; Free old selection-set if present
  32.    (setq ss (ssadd))                  ; Form empty selection-set
  33.    (if (null e)                       ; No previous stuff in drawing?
  34.        (setq ss (ssadd (setq e (entnext)) ss))  ; Start with what we drew
  35.    )
  36.    (while (setq e (entnext e))        ; Scan until end of drawing
  37.        (setq ss (ssadd e ss))         ; Add each entity to selection-set
  38.    )
  39.    ss                                 ; Return selection-set
  40. )
  41.  
  42. ; Draw Spring
  43. (defun spring (/ beta cen cosa deltal deltat e flop j numrseg numtseg
  44.                 px1 px2 px3 px4 
  45.                 py1 py2 py3 py4
  46.                 pz1 pz2 pz3 pz4
  47.                 ss1 ss2 hf hinc totseg arrfac
  48.                 radl radt sina x xorg yorg zorg)
  49.  
  50.    (initget (+ 1 16))                 ; Center point - 3D okay, cannot be null
  51.    (setq cen (getpoint "\nSpring center point: "))
  52.  
  53.    (setq radl -1 radt 0)
  54.    (while (> radt radl)
  55.        (initget 7 "Diameter")         ; Radius cannot be zero, neg, or null
  56.        (setq radl (getdist cen "\n<Spring radius>/Diameter: "))
  57.        (if (= radl "Diameter")
  58.            (progn
  59.                (initget 7)            ; Diameter cannot be zero, neg, or null
  60.                (setq radl (/ (getdist cen "\nSpring diameter: ") 2.0))
  61.            )
  62.        )
  63.  
  64.        (initget 7 "Diameter")         ; Radius cannot be zero, neg, or null
  65.        (setq radt (getdist cen "\n<Tube radius>/Diameter: "))
  66.        (if (= radt "Diameter")
  67.            (progn
  68.                (initget 7)            ; Diameter cannot be zero, neg, or null
  69.                (setq radt (/ (getdist cen "\nTube diameter: ") 2.0))
  70.            )
  71.        )
  72.        (if (> radt radl)
  73.            (prompt "\nTube radius cannot exceed spring radius.")
  74.        )
  75.    )
  76.  
  77.    (setq hf (getdist cen "\nHeight per rotation: ")) ;NEW
  78.    (setq #rot (getint "\nNumber of rotations: "))
  79.  
  80.    (while (or (< numrseg 8) (> numrseg 24))
  81.        (initget 6)                    ; Cannot have zero or negative segs
  82.        (setq numrseg (getint "\nNumber of radial segments (8-24) <16>: "))
  83.        (if (null numrseg)
  84.            (setq numrseg 16)
  85.        )
  86.        (if (or (< numrseg 8) (> numrseg 24))
  87.            (prompt "\nOutside acceptable range.")
  88.        )
  89.    )
  90.  
  91.    (setq hinc (/ hf numrseg))     ;NEW
  92.    (setq totseg (* #rot numrseg))
  93.  
  94.    (while (or (< numtseg 8) (> numtseg 24))
  95.        (initget 6)                    ; Cannot have zero or negative segs
  96.        (setq numtseg (getint "\nNumber of tube segments (8-24) <16>: "))
  97.        (if (null numtseg)
  98.            (setq numtseg 16)
  99.        )
  100.        (if (or (< numtseg 8) (> numtseg 24))
  101.            (prompt "\nOutside acceptable range.")
  102.        )
  103.    )
  104.  
  105.    (setvar "BLIPMODE" 0)
  106.    (setq e (entlast)                   ; Take database checkpoint
  107.          cmark (entlast)
  108.          deltat (* 2.0 (/ pi numtseg))
  109.          deltal (* 2.0 (/ pi numrseg))
  110.          cosa (cos deltal)
  111.          sina (sin deltal)
  112.          xorg (car cen)
  113.          yorg (cadr cen)
  114.          zorg (caddr cen)
  115.          x (+ radl radt)
  116.          px1 (+ x xorg)
  117.          py1 yorg
  118.          pz1 zorg
  119.          px2 (+ xorg (* x cosa))
  120.          py2 (+ yorg (* x sina))
  121.          pz2 (+ pz1 hinc)
  122.    )
  123.    (command "3DFACE" (list px1 py1 pz1) (list px2 py2 pz2))
  124.  
  125.    (setq doneface T j 1 flop 0)
  126.    (while (<= j numtseg)
  127.        (setq beta (* j deltat)
  128.              x (+ radl (* radt (cos beta)))
  129.              px3 (+ xorg (* x cosa))
  130.              py3 (+ yorg (* x sina))
  131.              pz3 (+ zorg (* radt (sin beta)) hinc)
  132.              px4 (+ xorg x)
  133.              py4 yorg
  134.              pz4 (- pz3 hinc)
  135.        )
  136.        (if (= 1 flop)
  137.            (command (list px4 py4 pz4) (list px3 py3 pz3))
  138.            (command (list px3 py3 pz3) (list px4 py4 pz4))
  139.        )
  140.        (setq flop (- 1 flop) j (+ j 1))
  141.    )
  142.    (command "")
  143.  
  144.    (setq ss1 (selstuff e))
  145.    (setq ss nil)
  146.    (setq arrfac 1)
  147.    (while (> numrseg arrfac)
  148.     (setq e (entlast))
  149.     (command "array" ss1 "" "c" cen (* arrfac (/ 360.0 numrseg)) "2" "y")
  150.     (setq ss2 (selstuff e))
  151.     (command "move" ss2 "" (list 0.0 0.0 0.0) (list 0.0 0.0 (* hinc arrfac)))
  152.     (setq ss2 nil)
  153.     (setq arrfac (+ arrfac 1))
  154.    )
  155.    (setq ss1 nil)
  156.    (setq ss3 (selstuff cmark))
  157.    (setq ctr 1)
  158.    (while (> #rot ctr)
  159.     (command "copy" ss3 "" (list 0 0 0) (list 0 0 (* ctr hf)))
  160.     (setq ctr (+ ctr 1))
  161.    )
  162.    (setq ss3 nil)
  163.    (setq ss nil)
  164. )
  165.  
  166.  
  167. ; Main program
  168. (defun C:SPRING (/ doneface olderr ss *error*)
  169.    (setq olderr *error* doneface nil)
  170.    (defun *error* (s)                  ; If an error (such as CTRL-C) occurs
  171.                                        ; while this command is active...
  172.        (if (/= s "Function cancelled")
  173.            (princ (strcat "\nError: " s))
  174.        )
  175.        (if doneface
  176.            (progn                      ; If we're drawing 3DFACEs...
  177.                (command)               ;   simulate CTRL-C (cancel 3DFACE cmd)
  178.                (command "UNDO" "END")  ;   terminate Undo group
  179.                (princ " ...undoing ")  ;   erase partially-drawn stuff
  180.                (command "U")
  181.            )
  182.        )
  183.        (moder)                         ; Restore modified modes
  184.        (setq ss nil)                   ; Free selection-set if any
  185.        (setq *error* olderr)           ; Restore old *error* handler
  186.        (princ)
  187.    )
  188.    (modes '("CMDECHO" "BLIPMODE" "HIGHLIGHT" "ELEVATION" "THICKNESS"))
  189.    (setvar "CMDECHO" 0)
  190.    (setvar "HIGHLIGHT" 0)
  191.    (spring)
  192.    (moder)
  193.    (princ)
  194. )
  195.